home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / env / jar-assem.scm < prev    next >
Text File  |  1995-10-13  |  4KB  |  134 lines
  1. ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  2. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  3.  
  4.  
  5. ; This is file assem.scm.
  6.  
  7. ;;;; Assembler
  8.  
  9. ; Courtesy John Ramsdell.
  10.  
  11. ; LAP syntax is much like that of the output of the disassembler except
  12. ; that global and set-global! take a symbol as an argument, 
  13. ; statements may be labeled, and jump, jump-if-false, and make-cont 
  14. ; may make a forward reference to a label to give an offset.
  15. ;
  16. ; Example: a translation of (define (dog) (if x 0 1)).
  17. ; (define dog
  18. ;   (lap dog
  19. ;     (check-nargs= 0)
  20. ;     (global x)
  21. ;     (jump-if-false 8)
  22. ;     (literal '0)
  23. ;   8 (jump out)
  24. ;     (literal '1)
  25. ; out (return)))
  26.  
  27. (define-compilator '(lap syntax)
  28.   (let ((op/closure (enum op closure)))
  29.     (lambda (node cenv depth cont)
  30.       (let ((exp (node-form node)))
  31.     (deliver-value
  32.      (instruction-with-template op/closure
  33.                     (compile-lap (cddr exp) cenv)
  34.                     (cadr exp))
  35.      cont)))))
  36.  
  37. ; Assembler label environments are simply a-lists.
  38. (define assembler-empty-env '())
  39. (define (assembler-extend sym val env) (cons (cons sym val) env))
  40. (define (assembler-lookup sym env)
  41.   (let ((val (assv sym env)))
  42.     (if (pair? val) (cdr val) #f)))
  43.  
  44. (define (compile-lap instruction-list cenv)
  45.   (assemble instruction-list
  46.         assembler-empty-env
  47.         cenv))
  48.  
  49. ; ASSEMBLE returns a segment.
  50.  
  51. (define (assemble instruction-list lenv cenv)
  52.   (if (null? instruction-list)
  53.       (sequentially)
  54.       (let ((instr (car instruction-list))
  55.         (instruction-list (cdr instruction-list)))
  56.     (cond ((pair? instr)        ; Instruction
  57.            (sequentially
  58.         (assemble-instruction instr lenv cenv)
  59.         (assemble instruction-list
  60.               lenv
  61.               cenv)))
  62.           ((or (symbol? instr)    ; Label
  63.            (number? instr))
  64.            (let ((label (make-label)))
  65.          (attach-label
  66.           label
  67.           (assemble instruction-list
  68.                 (assembler-extend instr label lenv)
  69.                 cenv))))
  70.           (else (error "invalid instruction" instr))))))
  71.  
  72. ; ASSEMBLE-INSTRUCTION returns a segment.
  73.  
  74. (define (assemble-instruction instr lenv cenv)
  75.   (let* ((opcode (name->enumerand (car instr) op))
  76.      (arg-specs (vector-ref opcode-arg-specs opcode)))
  77.     (cond ((or (not (pair? arg-specs))
  78.            (not (pair? (cdr instr))))
  79.        (instruction opcode))
  80.       ((eq? (car arg-specs) 'index)
  81.        (assemble-instruction-with-index opcode arg-specs (cdr instr) cenv))
  82.       ((eq? (car arg-specs) 'offset)
  83.        (let ((operand (cadr instr)))
  84.          (apply instruction-using-label
  85.             opcode
  86.             (let ((probe (assembler-lookup operand lenv)))
  87.               (if probe
  88.               probe
  89.               (begin
  90.                 (syntax-error "can't find forward label reference"
  91.                       operand)
  92.                 empty-segment)))
  93.             (assemble-operands (cddr instr) arg-specs))))
  94.       (else
  95.        (apply instruction
  96.           opcode
  97.           (assemble-operands (cdr instr) arg-specs))))))
  98.  
  99. ; <index> ::= (quote <datum>) | (lap <name> <instr>) | <name>
  100.  
  101. (define (assemble-instruction-with-index opcode arg-specs operands cenv)
  102.   (let ((operand (car operands)))
  103.     (if (pair? operand)
  104.     (case (car operand)
  105.       ((quote)
  106.        (instruction-with-literal opcode
  107.                      (cadr operand)))
  108.       ((lap)
  109.        (instruction-with-template opcode
  110.                       (compile-lap (cddr operand))
  111.                       (cadr operand)))
  112.       (else
  113.        (syntax-error "invalid index operand" operand)
  114.        empty-segment))
  115.     ;; Top-level variable reference
  116.     (instruction-with-location
  117.      opcode
  118.      (get-location (lookup cenv operand)
  119.                cenv
  120.                operand
  121.                value-type)))))
  122.  
  123. (define (assemble-operands operands arg-specs)
  124.   (map (lambda (operand arg-spec)
  125.      (case arg-spec
  126.        ((stob) (or (name->enumerand operand stob)
  127.                (error "unknown stored object type" operand)))
  128.        ((byte nargs) operand)
  129.        (else (error "unknown operand type" operand arg-spec))))
  130.        operands
  131.        arg-specs))
  132.  
  133. (define byte-limit (expt 2 bits-used-per-byte))
  134.